Optional Images.f

{ TODO

testing
grab framebuffer

}

Requires SDL
Requires SORA/Surfaces
Requires DevIL
Requires SEKI
Requires OpenGL\EXT-FBO
Requires Dorothy.f

only forth definitions

type: fbo end-type

type: cache
   int.field size
end-type

: cache.count  @+ ;

: fbo.bind ( fbo -- )
   glBindFramebufferEXT( GL_FRAMEBUFFER_EXT  swap ) ;

: fbo.unbind  ( -- )
   glBindFramebufferEXT( GL_FRAMEBUFFER_EXT  0 ) ;

: fbo.verify
   bind
   GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
   cr GL_FRAMEBUFFER_COMPLETE_EXT <> if ." FBO not complete " else ." FBO OK!" then
   fbo.unbind ;


type: subimage
   rectangle.field box
   goback
   short.field x
   short.field y
   short.field w
   short.field h
   short.field ox

   short.field oy
   short.field next
   goback short.field xstride  \ for symbols
   short.field delay
end-type

Node Extend: Image
   cache.pointer source     \ file in memory
   texture.pointer tex
   int.field texture-x     \ offset that has been applied to subimages
   int.field texture-y
   int.field image-w     \ dims of the surface
   int.field image-h
   int.field texw     \ dims of the texture
   int.field texh
   fbo.pointer fb           \ framebuffer object
   int.field dbrb           \ depthbuffer renderbuffer
   subimage.pointer subimages
   surface.pointer surf
end-type

node.make images
-? 0 surface.ref s

\ =========================================================
\ Textures

method: image.maketex
   surf.copy.prepare to s
   s.maketex  texture !  s.dims  texw.2!  s.destroy  ;

method: image.updatetex   ( rect -- )
   tex  surf.updatetex  ;

\ =========================================================
\ Palettes

type: palette
   256 int.field[] colors
end-type

: Palette:  ( -- <name> )
   here palette.sizeof cell/ 0 do $deadbeef , loop
   palette.const ;

method: palette.save  ( filename count -- )
   file:[  empty-file  colors  256 int.*  rot  write-file  throw  ;] ;

: slurp
   -rot  file:[  read-file  throw  drop  ;]  ;

macro: palette.load  ( filename count palette -- )   slurp ;

\ =========================================================
\ Loading/Saving support

\ Creates a temporary DevIL image, deleting it after the quotation is finished.
:[] il:[   ( xt -- ) ( il-image -- )
   ilInit ilGenImage dup >q ilBindImage catch q> ilDeleteImage throw ilShutDown ;

: il-dims   IL_IMAGE_WIDTH ilGetInteger IL_IMAGE_HEIGHT ilGetInteger ;

: surface.il  ( surface -- success? )
   dup >r dims 1 4 IL_BGRA IL_UNSIGNED_BYTE  0 0 r> pixel[].@ ilTexImage ;

: surface.ilformat
   dup has-alpha? IF
      red-first? IF IL_RGBA ELSE IL_BGRA THEN
   ELSE
      red-first? IF IL_RGB ELSE IL_BGR THEN
   THEN ;

: il-load-lump
   2dup 2>r ilDetermineTypeL 2r> ilLoadL 0= abort" Error loading image from memory. (DevIL)" ;

: il-create-surface
   IL_PAL_RGBA32 ilConvertPal 0= abort" Error converting palette. (DevIL)"
   il-dims new-surface to S
   ilCopyPixels(  0  0  0  il-dims   1  IL_BGRA  IL_UNSIGNED_BYTE  0 0 s.pixel[] ) drop ;

: surface.load  ( filename count -- surface )
   z$ locals| filename |
   il:[
      filename ilLoadImage 0= abort" Error loading image from file. (DevIL)"
      il-create-surface
   ;] S ;

: surface.loadp  ( filename count palette -- surface )
   -rot z$ locals| filename palette |
   il:[
      filename ilLoadImage 0= abort" Error loading image from file. (DevIL)"
      il-create-surface
      ilGetPalette  ( dup mem )  palette  256  cells  move
   ;] S ;

\ Bit-depths 8 and 32 are supported
method: surface.save ( bitdepth filename count -- )
   z$ locals| filename bitdepth |
   il:[
      S.il 0=
         abort" Error converting surface to image for saving. (DevIL)"
      bitdepth 8 = if
         ilConvertImage( IL_COLOR_INDEX IL_UNSIGNED_BYTE )
            0= abort" Error converting image before saving. (DevIL)"
         ilConvertPal( IL_PAL_RGBA32 )
            0= abort" Error converting palette. (DevIL)"
      else
         ilConvertImage( IL_RGBA IL_UNSIGNED_BYTE )
            0= abort" Error converting image before saving. (DevIL)"
      then
      ilHint( IL_USE_COMPRESSION IL_COMPRESSION_HINT )
      \ Not sure if this is always needed, but so far BMP, PNG, and JPG all required it... maybe it's something else that I'm doing????
         iluFlipImage
      filename zcount delete-file drop
      filename ilSaveImage
         0= abort" Error saving image. Maybe the file is locked. (DevIL)"
   ;] ;

\ =========================================================
\ Loading/Saving

: image.load  ( filename count image -- )
   >r surface.load to r>.surf ;

: image.loadp  ( filename count palette image -- )
   >r surface.loadp  to r>.surf ;

: image.save  ( filename count bitdepth image -- )
   surf.save  ;

\ =========================================================
{
: new-image
   /Image allocate throw

: destroy-image

: forget-image
   dup ->surface @ sdl-destroy
   ->texture @ free-texture ;

: copy-image  ( image1 -- image2 )
   dup forget-image
   swap ->surface @ sdl-copy swap ->surface ! ;
}

\ =========================================================
\ Drawing

\ TEXGRAN
\ Defines how much space the value of 1 takes in the bound texture
\  The texture goes from 0e-1.0e so we are expressing that as a ratio here.  x/y : w/h
\  It's OK to use either fixed point or integers here, so long all the parameters given are the same type.
\  To get very fine fixed point texture precision, make granx and grany 1 and texw and texh fixed point.
\  This is pretty slow.
: texgran  ( granx grany texw texh -- )
   tm-identity   swap  glscaled(  1e p>f f/ swap p>f f*   1e p>f f/ p>f f*   1e ) ;

method: image.bindtex ( granx grany image -- )
   tex.bind  texw.2@  texgran ;

: image.bind ( image -- )
   1 1 rot bindtex ;

\ -- Subimages --

\ Subimages format:
\  x , y , w , h , origin-x , origin-y , x-stride (for fonts) , char# (for fonts) , (all 16bit signed half's)
\                                        delay (for sprites) , jump (for sprites)

: Subimages:  ( image -- )   here  swap  to  image.subimages  ;

macro: image.dims  image.texw.2@ ;
macro: image.width  image.texh.@ ;
macro: image.height  image.texw.@ ;



\ initialize image - if an image has source data, create the image's surface from it.

method: image.init
   this .
   this.source 0= ?exit
   il:[  this.source.count  2 . il-load-lump  3 . il-create-surface  4 .  ;]
   S.dims image-w.2!
   S.make-32bit.colorkey-alpha to surf ;



\ Free memory taken by an image's surface
: image.free
   surf.@.destroy ;

: image.revert
   dup free init ;


\ =========================================================
\ Framebuffers


method: image.resize ( w h image -- )
   surf.resize  surf.destroy  to surf ;

method: image.makefb ( w h image -- )
   resize
   \ Framebuffer
   glGenFramebuffersEXT( 1  &of fb )
   glBindFramebufferEXT( GL_FRAMEBUFFER_EXT  fb )
   glFramebufferTexture2DEXT( GL_FRAMEBUFFER_EXT  GL_COLOR_ATTACHMENT0_EXT  GL_TEXTURE_2D  tex  0 )
   \ for depth buffer support
   glGenRenderbuffersEXT( 1  dbrb )
   glBindRenderbufferEXT( GL_RENDERBUFFER_EXT  dbrb.@ )
   glRenderbufferStorageEXT( GL_RENDERBUFFER_EXT  GL_DEPTH_COMPONENT24  texw.2@ )
   glFramebufferRenderbufferEXT( GL_FRAMEBUFFER_EXT  GL_DEPTH_ATTACHMENT_EXT  GL_RENDERBUFFER_EXT  dbrb.@ )
   cr ." Checking image FBO..." fb.verify
   fbo.unbind ;

method: image.freefb ( image -- )
   glDeleteFramebuffersEXT( 1  &of fb ) ;

\ : grab-framebuffer

method: image.bindfb ( image -- )
   fb.bind
      glPushAttrib( GL_VIEWPORT_BIT )
      glViewport(  0  0  image-w.2@  ) ;

\ special 2D projection mode for framebuffer objects - puts things rightside up
method: image.fb2dmode ( image -- )
   pm-identity   glOrtho(  -0.5e   image-w.@ s>f -0.5e f+  -0.45e  image-h.@ s>f -0.45e f+  1024e -1024e )
   true to 2dmode?  mv-identity ;

: image.unbindfb ( -- )
   glPopAttrib   fbo.unbind  ;

:[] image.offscreen:[  ( image xt -- )
   over bindfb execute unbindfb ;

:[] image.offscreen2d:[  ( image xt -- )
   over bindfb over fb2dmode execute unbindfb ;

\ =========================================================
\ Init/Cleanup

: init-images
   images.each:[
      image.<<
         source  if    init
                 else  image-w.2@  surface.new  to surf
         then >>
  ;] ;

: init-textures
   images.each:[ image.maketex ;] ;

: free-images
   images.each:[ image.free ;] ;


:onload
   cr ." Initializing surfaces...
   init-images ;

:prune
   cr ." Freeing surfaces...
   free-images ;

\ =========================================================
\ Instantiation - TODO

: image.construct ( w h image -- )
   2dup   new-surface to surf  image-w.2!
   this images.add ;
' image.construct >delegate image construct

: Graphic:  ( filename count -- <name> )
   image.make
   lastbody.@ image.<<
      this .
      here to this.source
      cache-file,
      this.init
   >> ;

\ Misc

macro: image.pixel[]  ( x y image -- addr )  image.surf.pixel[] ;

